;;
;;Edit-Bitmap. 
;;Copied from Luke Tierney's book with modifications by Fabian Camacho.
;;

;;function to make hi-icons.  not used by vista because much faster to use
;;stored result.  useful for creating the matrices, to be written into file.
(defun make-hi-icon (icon)
"Args: ICON
Function to make a hi-icon bitmap from an ICON bitmap."
  (let* ((hi-icon (* -1 (- icon 1)))
         (size (array-dimensions icon))
         (nrows (first size))
         (ncols (second size))
         )
    (dolist (i (iseq nrows))
            (setf (aref hi-icon i 0) 1)
            (setf (aref hi-icon i (- ncols 1)) 1)
            (setf (aref hi-icon i (- ncols 2)) 0)
            )
    (dolist (i (iseq ncols))
            (setf (aref hi-icon 0 i) 1)
            (setf (aref hi-icon (- nrows 1) i) 1)
            (setf (aref hi-icon (- nrows 2) i) 0)
            )
    (setf (aref hi-icon (- nrows 2) (- ncols 1)) 1)
    (setf (aref hi-icon (- nrows 2) 0) 1)
    (setf (aref hi-icon (- nrows 1) 0) 0)
    (setf (aref hi-icon 0 (- ncols 1)) 0)
    hi-icon))

(defun get-bitmap ()
"Args: None
Returns bitmap being created by bitmap editor"
  (send *bitmap* :bitmap))

(defun bitmap-editor ()
  (let* ((title  (send text-item-proto :new "BITMAP EDITOR"))
         (trows  (send text-item-proto :new "Rows in Bitmap"))
         (tcols  (send text-item-proto :new "Columns in Bitmap"))
         (tpix   (send text-item-proto :new "Pixel Size in Bitmap"))
         (nrows  (send edit-text-item-proto :new "20"))
         (ncols  (send edit-text-item-proto :new "20"))
         (npix   (send edit-text-item-proto :new "15"))
         (ok     (send modal-button-proto   :new "OK"
                       :action #'(lambda ()
                       (list (read-from-string (send nrows :text))
                             (read-from-string (send ncols :text))
                             (read-from-string (send npix  :text))) )))
         (cancel (send modal-button-proto   :new "Cancel"))
         (dialog (send modal-dialog-proto  :new
                       (list title 
                             (list nrows trows) 
                             (list ncols tcols)
                             (list npix  tpix) 
                             (list ok cancel))))
         (result (send dialog :modal-dialog))
         (x) (y) (pix))
    (when result
          (setf y (first result))
          (setf x (second result))
          (setf pix (third result))
          (edit-bitmap x y pix))))

(defun edit-bitmap (&optional (x 20) (y 20) (pixsize 15))
"Args: &Optional (X 20) (Y 20) (pixsize 15) &KEY (BITMAP nil)
Creates a large version of a bitmap of size x by y (20 X 20 default). Each pixel is represented by a square of pixsize pixels, smaller if too big for screen. Dragging makes all bits color of original cell. Creates  a bitmap object named *bitmap* and returns its object identification."

  (let* ((npix (min pixsize
                    (floor (/ (first screen-size)  x))
                    (floor (/ (second screen-size) y))))
         (size (list (* npix x) (* npix y)))
         (location (/ (- (screen-size) size) 2))
         (bitmap-window (send graph-window-proto :new :show nil))
         (object (send bitmap-edit-proto :new 
                       :size size
                       :show nil))
        )  
    (send object :bitmap (make-array (list y x) :initial-element 0)) 
    (send object :bitmap-window bitmap-window)
    (send bitmap-window :size (first size) (max 50 (second size)))
    (send bitmap-window :location (first location) 1)
    (send bitmap-window :title " ")
    (apply #'send object :size size)
    (send object :location (first location) y)
    (send object :title "Bitmap Editor")
    (send bitmap-window :add-slot 'bitmap)
    (defmeth bitmap-window :bitmap (&optional (matrix nil set)) 
      (if set (setf (slot-value 'bitmap) matrix))
      (slot-value 'bitmap))
    (send bitmap-window :bitmap (send object :bitmap))
    (defmeth bitmap-window :redraw ()
      (let* ((offset (+ 50 (array-dimension (send self :bitmap) 1)))
             (num  (ceiling (/ (send self :canvas-width) offset)))
             )
        (print offset)
        (print num)
        (dotimes (i num)
                 (send self :draw-bitmap 
                       (send self :bitmap) 
                       (* i offset) 1))))
    (defmeth object :close ()
      (call-next-method)
      (send bitmap-window :close))
    (send bitmap-window :show-window)
    (send object :show-window)
    (send bitmap-window :location 
          (first (send bitmap-window :location)) 0)
    (setf *bitmap* object)
    object))
 

(defproto bitmap-edit-proto
        '(bitmap h v bitmap-window) nil graph-window-proto)

(defmeth bitmap-edit-proto :isnew (&rest args) 
  (apply #'call-next-method args))

(defmeth bitmap-edit-proto :bitmap (&optional (matrix nil set)) 
  (if set (setf (slot-value 'bitmap) matrix))
  (slot-value 'bitmap))

(defmeth bitmap-edit-proto :bitmap-window (&optional (objid nil set)) 
  (if set (setf (slot-value 'bitmap-window) objid))
  (slot-value 'bitmap-window))

(defmeth bitmap-edit-proto :v () (slot-value 'v))

(defmeth bitmap-edit-proto :h () (slot-value 'h))

(defmeth bitmap-edit-proto :resize ()
   (let ((m (array-dimension (send self :bitmap) 0))
         (n (array-dimension (send self :bitmap) 1))
         (height (send self :canvas-height))
         (width  (send self :canvas-width)))
       
     (setf (slot-value 'v)
           (coerce (floor (* (iseq 0 m) (/ height m))) 'vector))

     (setf (slot-value 'h)
           (coerce (floor (* (iseq 0 n) (/ width n))) 'vector))))

(defmeth bitmap-edit-proto :draw-pixel (i j)
   (let* ((b (send self :bitmap))
          (v (send self :v))
          (h (send self :h))
          (left (aref h j))
          (right (aref h (+ j 1)))
          (top (aref v i))
          (bottom (aref v (+ i 1))))
    
   (send self (if (= 1 (aref b i j)) :paint-rect :erase-rect)
         left top (- right left) (- bottom top))))


(defmeth bitmap-edit-proto :redraw ()
    (let* ((b (send self :bitmap))
           (m (array-dimension b 0))
           (n (array-dimension b 1))
           (bitwin (send self :bitmap-window))
           (width (send self :canvas-width))
           (height (send self :canvas-height))
           (when(not width) (setf width 250))
           (when(not height) (setf height 250)))
      (send self :start-buffering)
      (dotimes (i m)
               (dotimes (j n)
                        (send self :draw-pixel i j)))
      (send self :buffer-to-screen)
    ;  (send bitwin :erase-rect 0 0 width height)
    ;  (send bitwin :draw-bitmap b 0 0)
      ))

(defmeth bitmap-edit-proto :set-pixel (x y color)
   (let* ((b (send self :bitmap))
          (m (array-dimension b 0))
          (n (array-dimension b 1))
          (width (send self :canvas-width))
          (height (send self :canvas-height))
          (i (min (floor (* y (/ m height))) (- m 1)))
          (j (min (floor (* x (/ n width))) (- n 1))))
           
     (setf (aref b i j) color)
     (send self :draw-pixel i j)
     (send self :transfer-bitmap)
     ))

(defmeth bitmap-edit-proto :black-or-white (x y)
    (let* ((b (send self :bitmap))
          (m (array-dimension b 0))
          (n (array-dimension b 1))
          (width (send self :canvas-width))
          (height (send self :canvas-height))
          (i (min (floor (* y (/ m height))) (- m 1)))
          (j (min (floor (* x (/ n width))) (- n 1))))

     (if (= (aref b i j) 1) 0 1))) 

(defmeth bitmap-edit-proto :do-click (x y m1 m2)
  (let ((color (send self :black-or-white x y)))
       (send self :set-pixel x y color)
      
       (send self :while-button-down #'(lambda (x y) (send self :set-pixel
x y color)))))


(defmeth bitmap-edit-proto :transfer-bitmap () 
  (send (send self :bitmap-window) :bitmap (send self :bitmap))
  (send (send self :bitmap-window) :redraw))

 



  
